*+--------------------------------------------------------------------------
*
*	File:		SCCTEXT.PRG
*
*	Copyright:	(c) 1995, Microsoft Corporation.
*				All Rights Reserved.
*
*	Contents:	Routines for creating text representations of .SCX, .VCX,
*				.MNX, .FRX, and .LBX files for the purpose of supporting
*				merge capabilities in source control systems.
*
*   Author:		Sherri Kennamer
*
*	Parameters:	cTableName	C	Fully-qualified name of the SCX/VCX/MNX/FRX/LBX
*				cType		C	Code indicating the file type
*								(See PRJTYPE_ constants, defined below)
*				cTextName	C	Fully-qualified name of the text file
*				lGenText	L	.T. Create a text file from the table
*								.F. Create a table from the text file
*
*	Returns:	0		File or table was successfully generated
*				-1		An error occurred
*
*	History:	17-Aug-95	sherrike	written
*				20-Nov-95	sherrike	use smart defaults for single filename
*				02-Dec-95	sherrike	return values for merge support
*				16-Oct-02	bethm		write methods in alphabetical order
*
*---------------------------------------------------------------------------

#include "foxpro.h"

#define C_DEBUG .F.

* If merge support is 1 and C_WRITECHECKSUMS is .T., write a checksum (sys(2007)) instead of
* converting binary to ascii. This drastically improves performance because OLE controls can
* be large and time-consuming to convert.
#define C_WRITECHECKSUMS .T.

#define SCCTEXTVER_LOC "SCCTEXT Version 4.0.0.2"

#define ALERTTITLE_LOC "Microsoft Visual FoxPro"
#define ERRORTITLE_LOC "Program Error"
#define ERRORMESSAGE_LOC ;
	"Error #" + alltrim(str(m.nError)) + " in " + m.cMethod + ;
	" (" + alltrim(str(m.nLine)) + "): " + m.cMessage

#define ERR_FOXERROR_11_LOC "Function argument value, type, or count is invalid."
#define ERR_NOTABLE_LOC "A table name is required."
#define ERR_FILENOTFOUND_LOC "File not found: "
#define ERR_UNSUPPORTEDFILETYPE_LOC "File type not supported: "
#define ERR_BIN2TEXTNOTSUPPORTED_LOC "Text file generation not supported for type '&cType' files."
#define ERR_TEXT2BINNOTSUPPORTED_LOC "Binary file generation not supported for type '&cType' files."
#define ERR_UNSUPPORTEDFIELDTYPE_LOC "Field type not supported: "
#define ERR_INVALIDTEXTNAME_LOC "Invalid TEXTNAME parameter."
#define ERR_INVALIDREVERSE_LOC "Invalid REVERSE parameter."
#define ERR_NOTEXTFILE_LOC "Text file name is required to create a table."
#define ERR_FCREATE_LOC "FCREATE() error: "
#define ERR_FOPEN_LOC "FOPEN() error: "
#define ERR_FIELDLISTTOOLONG_LOC "Field list is too long."
#define ERR_BADVERSION_LOC "Bad SCCTEXT version."
#define ERR_LINENOACTION_LOC "No action was taken on line: "
#define ERR_ALERTCONTINUE_LOC "Continue?"
#define ERR_OVERWRITEREADONLY_LOC "File &cParameter1 is read-only. Overwrite it?"
#define ERR_MAXBINLEN_LOC "MAXBINLEN value must be a multiple of 8. Program aborted."

#define CRLF chr(13) + chr(10)
#define MAXBINLEN	96		&& this value must be a multiple of 8!!!

#define FILE_ATTRIBUTE_NORMAL	128

* Text file support for each file type
*	0 indicates no text file support
*	1 indicates one-way support (to text)
*	2 indicates two-way support (for merging)
#define SCC_FORM_SUPPORT	1
#define SCC_LABEL_SUPPORT	1
#define SCC_MENU_SUPPORT	1
#define SCC_REPORT_SUPPORT	1
#define SCC_VCX_SUPPORT		1
#define SCC_DBC_SUPPORT		0

* These are the extensions used for the text file
#define SCC_ASCII_FORM_EXT		"SCA"
#define SCC_ASCII_LABEL_EXT		"LBA"
#define SCC_ASCII_MENU_EXT		"MNA"
#define SCC_ASCII_REPORT_EXT	"FRA"
#define SCC_ASCII_VCX_EXT		"VCA"
#define SCC_ASCII_DBC_EXT		"DBA"

* These are the extensions used for the binary file
#define SCC_FORM_EXT		"SCX"
#define SCC_LABEL_EXT		"LBX"
#define SCC_MENU_EXT		"MNX"
#define SCC_REPORT_EXT		"FRX"
#define SCC_VCX_EXT			"VCX"
#define SCC_DBC_EXT			"DBC"

* These are the extensions used for the binary file
#define SCC_FORM_MEMO		"SCT"
#define SCC_LABEL_MEMO		"LBT"
#define SCC_MENU_MEMO		"MNT"
#define SCC_REPORT_MEMO		"FRT"
#define SCC_VCX_MEMO		"VCT"
#define SCC_DBC_MEMO		"DBT"

* These are the project type identifiers for the files
#define PRJTYPE_FORM		"K"
#define PRJTYPE_LABEL		"B"
#define PRJTYPE_MENU		"M"
#define PRJTYPE_REPORT		"R"
#define PRJTYPE_VCX			"V"
#define PRJTYPE_DBC			"d"

* These are the extensions used for table backups
#define SCC_FORM_TABLE_BAK		"SC1"
#define SCC_FORM_MEMO_BAK		"SC2"
#define SCC_LABEL_TABLE_BAK		"LB1"
#define SCC_LABEL_MEMO_BAK		"LB2"
#define SCC_MENU_TABLE_BAK		"MN1"
#define SCC_MENU_MEMO_BAK		"MN2"
#define SCC_REPORT_TABLE_BAK	"FR1"
#define SCC_REPORT_MEMO_BAK		"FR2"
#define SCC_VCX_TABLE_BAK		"VC1"
#define SCC_VCX_MEMO_BAK		"VC2"
#define SCC_DBC_TABLE_BAK		"DB1"
#define SCC_DBC_MEMO_BAK		"DB2"
#define SCC_DBC_INDEX_BAK		"DB3"

* These are the extensions used for text file backups
#define SCC_FORM_TEXT_BAK		"SCB"
#define SCC_LABEL_TEXT_BAK		"LBB"
#define SCC_MENU_TEXT_BAK		"MNB"
#define SCC_REPORT_TEXT_BAK		"FRB"
#define SCC_VCX_TEXT_BAK		"VCB"
#define SCC_DBC_TEXT_BAK		"DBB"

* These are used for building markers used to parse the text back into a table
#define MARKMEMOSTARTWORD	"[START "
#define MARKMEMOSTARTWORD2	"]"
#define MARKMEMOENDWORD		"[END "
#define MARKMEMOENDWORD2	"]"
#define MARKBINSTARTWORD	"[BINSTART "
#define MARKBINSTARTWORD2	"]"
#define MARKBINENDWORD		"[BINEND "
#define MARKBINENDWORD2		"]"
#define MARKFIELDSTART		"["
#define MARKFIELDEND		"] "
#define MARKEOF				"[EOF]"
#define MARKRECORDSTART		"["
#define MARKRECORDEND		" RECORD]"
#define MARKCHECKSUM		"CHECKSUM="

#define SKIPEMPTYFIELD		.T.

* These are used to override default behavior for specific fields
#define VCX_EXCLUDE_LIST		" OBJCODE TIMESTAMP "
#define VCX_MEMOASCHAR_LIST		" CLASS CLASSLOC BASECLASS OBJNAME PARENT "
#define VCX_MEMOASBIN_LIST		" OLE OLE2 "
#define VCX_CHARASBIN_LIST		""
#define VCX_MEMOVARIES_LIST		" RESERVED4 RESERVED5 "

#define FRX_EXCLUDE_LIST		" TIMESTAMP "
#define FRX_MEMOASCHAR_LIST		" NAME STYLE PICTURE ORDER FONTFACE "
#define FRX_MEMOASBIN_LIST		" TAG TAG2 "
#define FRX_CHARASBIN_LIST		""
#define FRX_MEMOVARIES_LIST		""

#define MNX_EXCLUDE_LIST		" TIMESTAMP "
#define MNX_MEMOASCHAR_LIST		" NAME PROMPT COMMAND MESSAGE KEYNAME KEYLABEL "
#define MNX_MEMOASBIN_LIST		""
#define MNX_CHARASBIN_LIST		" MARK "
#define MNX_MEMOVARIES_LIST		""

#define DBC_EXCLUDE_LIST		""
#define DBC_MEMOASCHAR_LIST		""
#define DBC_MEMOASBIN_LIST		""
#define DBC_CHARASBIN_LIST		""
#define DBC_MEMOVARIES_LIST		" PROPERTY CODE USER "

* Used by the thermometer
#define C_THERMLABEL_LOC		"Generating &cThermLabel"
#define C_THERMCOMPLETE_LOC		"Generate &cThermLabel complete!"
#DEFINE WIN32FONT				"MS Sans Serif"
#DEFINE WIN95FONT				"Arial"
#define C_BINARYCONVERSION_LOC	"Converting binary data: &cBinaryProgress.%"

parameters cTableName, cType, cTextName, lGenText
LOCAL iParmCount
iParmCount = parameters()

LOCAL  obj, iResult
m.iResult = -1
if m.iParmCount = 1 .and. type('m.cTableName') = 'C'
	* Check to see if we've been passed only a PRJTYPE value. If so, return a
	* value to indicate text support for the file type.
	*	0 indicates no text file support
	*	1 indicates one-way support (to text)
	*	2 indicates two-way support (for merging)
	*  -1 indicates m.cTableName is not a recognized file type
	m.iResult = TextSupport(m.cTableName)
endif
if m.iResult = -1 && .and. file(m.cTableName)
	m.obj = createobj("SccTextEngine", m.cTableName, m.cType, m.cTextName, m.lGenText, m.iParmCount)
	if type("m.obj") = "O" .and. .not. isnull(m.obj)
		obj.Process()
		if type("m.obj") = "O" .and. .not. isnull(m.obj)
			m.iResult = obj.iResult
		endif
	endif
	release m.obj
endif
return (m.iResult)

procedure TextSupport
	parameters cFileType
	do case
	* Check to see if we've been passed only a PRJTYPE value. If so, return a
	* value to indicate text support for the file type.
	*	0 indicates no text file support
	*	1 indicates one-way support (to text)
	*	2 indicates two-way support (for merging)
	case m.cFileType == PRJTYPE_FORM
		return SCC_FORM_SUPPORT
	case m.cFileType == PRJTYPE_LABEL
		return SCC_LABEL_SUPPORT
	case m.cFileType == PRJTYPE_MENU
		return SCC_MENU_SUPPORT
	case m.cFileType == PRJTYPE_REPORT
		return SCC_REPORT_SUPPORT
	case m.cFileType == PRJTYPE_VCX
		return SCC_VCX_SUPPORT
	case m.cFileType == PRJTYPE_DBC
		return SCC_DBC_SUPPORT
	otherwise
		return -1
	endcase
endproc

define class SccTextEngine as custom
	HadError = .f.
	iError = 0
	cMessage = ""
	SetErrorOff = .f.

	iResult = -1 && Fail
	cTableName = ""
	cMemoName = ""
	cIndexName = ""
	cTextName = ""
	
	lMadeBackup = .F.
	cTableBakName = ""
	cMemoBakName = ""
	cIndexBakName = ""
	cTextBakName = ""
	
	cVCXCursor = ""		&& If we're generating text for a .VCX, we create a temporary
						&& file with the classes sorted.
	
	cType = ""
	lGenText = .t.
	iHandle = -1
	dimension aEnvironment[1]
	
	oThermRef = ""
	
	procedure Init(cTableName, cType, cTextName, lGenText, iParmCount)
		local iAction
		
		if m.iParmCount = 1 .and. type('m.cTableName') = 'C'
			* Interpret the single parameter as a filename and be smart about defaults
			if this.IsBinary(m.cTableName)
				m.cType = this.GetPrjType(m.cTableName)
				m.cTextName = this.ForceExt(m.cTableName, this.GetAsciiExt(m.cType))
				m.lGenText = .t.
			else
				if this.IsAscii(m.cTableName)
					m.cType = this.GetPrjType(m.cTableName)
					m.cTextName = m.cTableName
					m.cTableName = this.ForceExt(m.cTextName, this.GetBinaryExt(m.cType))
					m.lGenText = .f.
				endif
			endif
		endif
		
		this.cTableName = m.cTableName
		this.cType = m.cType
		this.cTextName = m.cTextName
		this.lGenText = m.lGenText
		
		* Verify that we've got valid parameters
		if type('this.cTableName') <> 'C' .or. type('this.cType') <> 'C' ;
			.or. type('this.cTextName') <> 'C' .or. type('this.lGenText') <> 'L'
			this.Alert(ERR_FOXERROR_11_LOC)
			return .f.
		endif
		
		* REC00XYS Verify parameters before calling this.ForceExt
		this.cMemoName = this.ForceExt(this.cTableName, this.GetBinaryMemo(this.cType))

		* Verify that we support the requested action
		m.iAction = iif(m.lGenText, 1, 2)
		do case
		case m.cType == PRJTYPE_FORM .and. SCC_FORM_SUPPORT < m.iAction
			m.iAction = m.iAction * -1
		case m.cType == PRJTYPE_LABEL .and. SCC_LABEL_SUPPORT < m.iAction
			m.iAction = m.iAction * -1
		case m.cType == PRJTYPE_MENU .and. SCC_MENU_SUPPORT < m.iAction
			m.iAction = m.iAction * -1
		case m.cType == PRJTYPE_REPORT .and. SCC_REPORT_SUPPORT < m.iAction
			m.iAction = m.iAction * -1
		case m.cType == PRJTYPE_VCX .and. SCC_VCX_SUPPORT < m.iAction
			m.iAction = m.iAction * -1
		case m.cType == PRJTYPE_DBC .and. SCC_DBC_SUPPORT < m.iAction
			m.iAction = m.iAction * -1
		endcase

		if m.iAction = -1
			this.Alert(ERR_BIN2TEXTNOTSUPPORTED_LOC)
			return .f.
		endif
		if m.iAction = -2
			this.Alert(ERR_TEXT2BINNOTSUPPORTED_LOC)
			return .f.
		endif
			
		if .not. this.Setup()
			return .f.
		endif
		
		if (MAXBINLEN % 8 <> 0)
			this.Alert(ERR_MAXBINLEN_LOC)
			return .f.
		endif
	endproc

	procedure Erase
		parameters cFilename
		if !empty(m.cFilename) .and. file(m.cFilename)
			=SetFileAttributes(m.cFilename, FILE_ATTRIBUTE_NORMAL)
			erase (m.cFilename)
		endif
	endproc
	
	procedure MakeBackup
		* Fill in the names of the backup files
		do case
		case this.cType = PRJTYPE_FORM
			this.cTextBakName = this.ForceExt(this.cTextName, SCC_FORM_TEXT_BAK)
			this.cTableBakName = this.ForceExt(this.cTableName, SCC_FORM_TABLE_BAK)
			this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_FORM_MEMO_BAK)
		case this.cType = PRJTYPE_REPORT
			this.cTextBakName = this.ForceExt(this.cTextName, SCC_REPORT_TEXT_BAK)
			this.cTableBakName = this.ForceExt(this.cTableName, SCC_REPORT_TABLE_BAK)
			this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_REPORT_MEMO_BAK)
		case this.cType = PRJTYPE_VCX
			this.cTextBakName = this.ForceExt(this.cTextName, SCC_VCX_TEXT_BAK)
			this.cTableBakName = this.ForceExt(this.cTableName, SCC_VCX_TABLE_BAK)
			this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_VCX_MEMO_BAK)
		case this.cType = PRJTYPE_MENU
			this.cTextBakName = this.ForceExt(this.cTextName, SCC_MENU_TEXT_BAK)
			this.cTableBakName = this.ForceExt(this.cTableName, SCC_MENU_TABLE_BAK)
			this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_MENU_MEMO_BAK)
		case this.cType = PRJTYPE_LABEL
			this.cTextBakName = this.ForceExt(this.cTextName, SCC_LABEL_TEXT_BAK)
			this.cTableBakName = this.ForceExt(this.cTableName, SCC_LABEL_TABLE_BAK)
			this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_LABEL_MEMO_BAK)
		case this.cType = PRJTYPE_DBC
			this.cTextBakName = this.ForceExt(this.cTextName, SCC_DBC_TEXT_BAK)
			this.cTableBakName = this.ForceExt(this.cTableName, SCC_DBC_TABLE_BAK)
			this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_DBC_MEMO_BAK)
			this.cIndexBakName = this.ForceExt(this.cIndexName, SCC_DBC_INDEX_BAK)
		endcase
		
		* Delete any existing backup
		this.DeleteBackup()
		
		* Create new backup files
		if this.lGenText
			if file(this.cTextName)
				copy file (this.cTextName) to (this.cTextBakName)
			endif
		else
			if file(this.cTableName) .and. file(this.cMemoName)
				copy file (this.cTableName) to (this.cTableBakName)
				copy file (this.cMemoName) to (this.cMemoBakName)
				if !empty(this.cIndexName) .and. file(this.cIndexName)
					copy file (this.cIndexName) to (this.cIndexBakName)
				endif
			endif
		endif

		this.lMadeBackup = .T.
	endproc
	
	procedure RestoreBackup
		if this.lGenText
			this.Erase(this.cTextName)
		else
			this.Erase(this.cTableName)
			this.Erase(this.cMemoName)
			if .not. empty(this.cIndexName)
				this.Erase(this.cIndexName)
			endif
		endif
		
		if this.lGenText
			if file(this.cTextBakName)
				copy file (this.cTextBakName) to (this.cTextName)
			endif
		else
			if file(this.cTableBakName) .and. file(this.cMemoBakName)
				copy file (this.cTableBakName) to (this.cTableName)
				copy file (this.cMemoBakName) to (this.cMemoName)
				if !empty(this.cIndexBakName) .and. file(this.cIndexBakName)
					copy file (this.cIndexBakName) to (this.cIndexName)
				endif
			endif
		endif
	endproc
	
	procedure DeleteBackup
		if this.lGenText
			this.Erase(this.cTextBakName)
		else
			this.Erase(this.cTableBakName)
			this.Erase(this.cMemoBakName)
			if !empty(this.cIndexBakName)
				this.Erase(this.cIndexBakName)
			endif
		endif
	endproc
	
	procedure GetAsciiExt
		parameters cType
		do case
		case m.cType = PRJTYPE_FORM
			return SCC_ASCII_FORM_EXT
		case m.cType = PRJTYPE_REPORT
			return SCC_ASCII_REPORT_EXT
		case m.cType = PRJTYPE_VCX
			return SCC_ASCII_VCX_EXT
		case m.cType = PRJTYPE_MENU
			return SCC_ASCII_MENU_EXT
		case m.cType = PRJTYPE_LABEL
			return SCC_ASCII_LABEL_EXT
		case m.cType = PRJTYPE_DBC
			return SCC_ASCII_DBC_EXT
		endcase
	endproc
	
	procedure GetBinaryExt
		parameters cType
		do case
		case m.cType = PRJTYPE_FORM
			return SCC_FORM_EXT
		case m.cType = PRJTYPE_REPORT
			return SCC_REPORT_EXT
		case m.cType = PRJTYPE_VCX
			return SCC_VCX_EXT
		case m.cType = PRJTYPE_MENU
			return SCC_MENU_EXT
		case m.cType = PRJTYPE_LABEL
			return SCC_LABEL_EXT
		case m.cType = PRJTYPE_DBC
			return SCC_DBC_EXT
		endcase
	endproc
	
	procedure GetBinaryMemo
		parameters cType
		do case
		case m.cType = PRJTYPE_FORM
			return SCC_FORM_MEMO
		case m.cType = PRJTYPE_REPORT
			return SCC_REPORT_MEMO
		case m.cType = PRJTYPE_VCX
			return SCC_VCX_MEMO
		case m.cType = PRJTYPE_MENU
			return SCC_MENU_MEMO
		case m.cType = PRJTYPE_LABEL
			return SCC_LABEL_MEMO
		case m.cType = PRJTYPE_DBC
			return SCC_DBC_MEMO
		endcase
	endproc
	
	procedure GetPrjType
		parameters cFileName
		local m.cExt
		m.cExt = upper(this.JustExt(m.cFileName))
		do case
		case inlist(m.cExt, SCC_ASCII_FORM_EXT, SCC_FORM_EXT)
			return PRJTYPE_FORM
		case inlist(m.cExt, SCC_ASCII_REPORT_EXT, SCC_REPORT_EXT)
			return PRJTYPE_REPORT
		case inlist(m.cExt, SCC_ASCII_VCX_EXT, SCC_VCX_EXT)
			return PRJTYPE_VCX
		case inlist(m.cExt, SCC_ASCII_MENU_EXT, SCC_MENU_EXT)
			return PRJTYPE_MENU
		case inlist(m.cExt, SCC_ASCII_LABEL_EXT, SCC_LABEL_EXT)
			return PRJTYPE_LABEL
		case inlist(m.cExt, SCC_ASCII_DBC_EXT, SCC_DBC_EXT)
			return PRJTYPE_DBC
		otherwise
			return ''
		endcase
	endproc
	
	procedure IsAscii
		parameters cFileName
		local m.cExt
		m.cExt = upper(this.JustExt(m.cFileName))
		return inlist(m.cExt, SCC_ASCII_FORM_EXT, SCC_ASCII_REPORT_EXT, SCC_ASCII_VCX_EXT, ;
			SCC_ASCII_MENU_EXT, SCC_ASCII_LABEL_EXT, SCC_ASCII_DBC_EXT)
	endproc
	
	procedure IsBinary
		parameters cFileName
		local m.cExt
		m.cExt = upper(this.JustExt(m.cFileName))
		return inlist(m.cExt, SCC_FORM_EXT, SCC_REPORT_EXT, SCC_VCX_EXT, ;
			SCC_MENU_EXT, SCC_LABEL_EXT, SCC_DBC_EXT)
	endproc
	
	procedure Setup
		
		dimension this.aEnvironment[5]
		
		this.aEnvironment[1] = set("deleted")
		this.aEnvironment[2] = select()
		this.aEnvironment[3] = set("safety")
		this.aEnvironment[4] = set("talk")
		this.aEnvironment[5] = set("asserts")
		
		SET TALK OFF

		declare INTEGER SetFileAttributes in win32api ;
			STRING lpFileName, INTEGER dwFileAttributes
		declare INTEGER sprintf in msvcrt40.dll ;
			STRING @lpBuffer, string lpFormat, integer iChar1, integer iChar2, ;
			integer iChar3, integer iChar4, integer iChar5, integer iChar6, ;
			integer iChar7, integer iChar8

		set safety off
		set deleted off
		select 0
		if C_DEBUG
			set asserts on
		endif
		
	endproc
	
	procedure Cleanup
		local array aEnvironment[alen(this.aEnvironment)]
		=acopy(this.aEnvironment, aEnvironment)
		set deleted &aEnvironment[1]
		set safety &aEnvironment[3]
		use
		select (aEnvironment[2])
		if this.iHandle <> -1
			=fclose(this.iHandle) 
			this.iHandle = -1
		endif
		SET TALK &aEnvironment[4]		
		if used(this.cVCXCursor)
			use in (this.cVCXCursor)
			this.cVCXCursor = ""
		endif
		set asserts &aEnvironment[5]
	endproc
	
	procedure Destroy
		if type("this.oThermRef") = "O"
			this.oThermRef.Release()
		endif
	
		this.Cleanup
		
		if this.lMadeBackup
			if this.iResult <> 0
				this.RestoreBackup()
			endif
			this.DeleteBackup()
		endif
	endproc
	
	PROCEDURE Error
		Parameters nError, cMethod, nLine, oObject, cMessage

		local cAction
		
		THIS.HadError = .T.
		this.iError = m.nError
		this.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
	
		if this.SetErrorOff
			RETURN
		endif
		
		m.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
		if type("m.oObject") = "O" .and. .not. isnull(m.oObject) .and. at(".", m.cMethod) = 0
			m.cMethod = m.oObject.Name + "." + m.cMethod
		endif
				
		if C_DEBUG
			m.cAction = this.Alert(ERRORMESSAGE_LOC, MB_ICONEXCLAMATION + ;
				MB_ABORTRETRYIGNORE, ERRORTITLE_LOC)
			do case
			case m.cAction="RETRY"
				this.HadError = .f.
				clear typeahead
				set step on
				&cAction
			case m.cAction="IGNORE"
				this.HadError = .f.
				return
			endcase
		else
			if m.nError = 1098
				* User-defined error
				m.cAction = this.Alert(message(), MB_ICONEXCLAMATION + ;
					MB_OK, ERRORTITLE_LOC)
			else
				m.cAction = this.Alert(ERRORMESSAGE_LOC, MB_ICONEXCLAMATION + ;
					MB_OK, ERRORTITLE_LOC)
			endif
		endif
		this.Cancel

	ENDPROC
	
	procedure Cancel
		parameters cMessage
		if !empty(m.cMessage)
			m.cAction = this.Alert(m.cMessage)
		endif
		return to Process -1
	endproc
	
	PROCEDURE Alert
		parameters cMessage, cOptions, cTitle, cParameter1, cParameter2

		private cOptions, cResponse

		m.cOptions = iif(empty(m.cOptions), 0, m.cOptions)

		if parameters() > 3 && a parameter was passed
			m.cMessage = [&cMessage]
		endif
		
		clear typeahead
		if !empty(m.cTitle)
			m.cResponse = MessageBox(m.cMessage, m.cOptions, m.cTitle)
		else
			m.cResponse = MessageBox(m.cMessage, m.cOptions, ALERTTITLE_LOC)
		endif

		do case
		* The strings below are used internally and should not 
		* be localized
		case m.cResponse = 1
			m.cResponse = "OK"
		case m.cResponse = 6
			m.cResponse = "YES"
		case m.cResponse = 7
			m.cResponse = "NO"
		case m.cResponse = 2
			m.cResponse = "CANCEL"
		case m.cResponse = 3
			m.cResponse = "ABORT"
		case m.cResponse = 4
			m.cResponse = "RETRY"
		case m.cResponse = 5
			m.cResponse = "IGNORE"
		endcase
		return m.cResponse

	ENDPROC

	procedure Process
		local cThermLabel
		
		if this.FilesAreWritable()
			* Backup the file(s)

			this.MakeBackup()
			
			* Create and show the thermometer
			m.cThermLabel = iif(this.lGenText, this.cTextName, this.cTableName)
			this.oThermRef = createobject("thermometer", C_THERMLABEL_LOC)
			this.oThermRef.Show()
			
			if this.lGenText
				this.iResult = this.WriteTextFile()
			else
				this.iResult = this.WriteTableFile()
			endif
			
			if this.iResult = 0
				this.oThermRef.Complete(C_THERMCOMPLETE_LOC)
			endif
		endif
	endproc
	
	procedure FilesAreWritable
		private aText
		if this.lGenText
			* Verify we can write the text file
			if (adir(aText, this.cTextName) = 1 .and. 'R' $ aText[1, 5])
				if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cTextName) = "NO"
					return .f.
				endif
			endif
			=SetFileAttributes(this.cTextName, FILE_ATTRIBUTE_NORMAL)
		else
			* Verify we can write the table
			if (adir(aText, this.cTableName) = 1 .and. 'R' $ aText[1, 5])
				if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cTableName) = "NO"
					return .f.
				endif
			else
				if (adir(aText, this.cMemoName) = 1 .and. 'R' $ aText[1, 5])
					if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cMemoName) = "NO"
						return .f.
					endif
				endif
			endif
			=SetFileAttributes(this.cTableName, FILE_ATTRIBUTE_NORMAL)
			=SetFileAttributes(this.cMemoName, FILE_ATTRIBUTE_NORMAL)
		endif
		return .t.
	endproc
	
	procedure WriteTableFile
		this.iHandle = fopen(this.cTextName)
		if this.iHandle = -1
			this.Alert(ERR_FOPEN_LOC + this.cTextName)
			return -1
		endif

		this.oThermRef.iBasis = fseek(this.iHandle, 0, 2)
		fseek(this.iHandle, 0, 0)
		
		this.ValidVersion(fgets(this.iHandle, 8192))
		this.CreateTable(fgets(this.iHandle, 8192), val(fgets(this.iHandle, 8192)))
		do case
			case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX, PRJTYPE_MENU, ;
				PRJTYPE_REPORT, PRJTYPE_LABEL)
				this.WriteTable
			otherwise
				this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + this.cType)
		endcase
		
		=fclose(this.iHandle)
		this.iHandle = -1
		if inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX)
			if this.cType = PRJTYPE_VCX
				* Additional work may need to be performed on a VCX
				this.FixUpVCX
			endif
			
			use
			compile form (this.cTableName)
		endif
		use
		return 0 && Success
	endproc
	
	procedure FixUpVCX
		private aClassList, i
		select objname, recno() from dbf() where not deleted() and reserved1 == 'Class' ;
			into array aClassList
		if type('aClassList[1]') <> 'U'
			* If objects were added to or removed from a class during merge, 
			* the record count will be out of sync.
			for m.i = 1 to alen(aClassList, 1)
				go (aClassList[m.i, 2])
				if m.i = alen(aClassList, 1)
					replace reserved2 with ;
						alltrim(str(reccount() - aClassList[m.i, 2]))
				else
					replace reserved2 with ;
						alltrim(str(aClassList[m.i + 1, 2] - aClassList[m.i, 2] - 1))
				endif
			endfor
		endif
	endproc
	
	procedure CreateTable
		parameters cFieldlist, iCodePage
		private c1, c2, c3, c4, c5, c6, aStruct

		do case
			* BugBug: This is a workaround for the problem with CREATE TABLE and a long
			* field list
			case inlist(this.cType, PRJTYPE_REPORT, PRJTYPE_LABEL)
				dimension aStruct[75, 4]
				this.GetReportStructure(@aStruct)
				create table (this.cTableName) free from array aStruct
				release aStruct
				if .not. m.cFieldlist == this.Fieldlist()
					this.Cancel(ERR_FIELDLISTTOOLONG_LOC)
				endif
			case len(m.cFieldlist) < 251
				create table (this.cTableName) free (&cFieldList)
			case len(m.cFieldlist) < 501
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251)
				create table (this.cTableName) free (&c1&c2)
			case len(m.cFieldlist) < 751
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501)
				create table (this.cTableName) free (&c1&c2&c3)
			case len(m.cFieldlist) < 1001
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501, 250)
				m.c4 = substr(m.cFieldlist, 751)
				create table (this.cTableName) free (&c1&c2&c3&c4)
			case .f. .and. len(m.cFieldlist) < 1251
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501, 250)
				m.c4 = substr(m.cFieldlist, 751, 250)
				m.c5 = substr(m.cFieldlist, 1001)
				* BugBug: This causes an error
				create table (this.cTableName) free (&c1&c2&c3&c4&c5)
			case .f. .and. len(m.cFieldlist) < 1501
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501, 250)
				m.c4 = substr(m.cFieldlist, 751, 250)
				m.c5 = substr(m.cFieldlist, 1001, 250)
				m.c6 = substr(m.cFieldlist, 1251)
				* BugBug: This causes an error
				create table (this.cTableName) free (&c1&c2&c3&c4&c5&c6)
			otherwise
				* Not supported
				this.Cancel(ERR_FIELDLISTTOOLONG_LOC)
		endcase
		if cpdbf() <> m.iCodePage
			use
			this.SetCodePage(this.cTableName, m.iCodePage)
		endif
		use (this.cTableName) exclusive
	endproc
	
	procedure ValidVersion
		parameters cVersion
		if .not. m.cVersion == SCCTEXTVER_LOC
			this.Cancel(ERR_BADVERSION_LOC)
		endif
	endproc
	
	procedure FieldList
		* Returns a CREATE TABLE compatible field list for the current workarea.
		local cStruct, i
		local array aStruct[1]
		
		=afields(aStruct)
		m.cStruct = ""
		for m.i = 1 to alen(aStruct, 1)
			if .not. empty(m.cStruct)
				m.cStruct = m.cStruct + ","
			endif
			m.cStruct = m.cStruct + aStruct[m.i, 1] + " " + aStruct[m.i, 2] + ;
				"(" + alltrim(str(aStruct[m.i, 3])) + "," + ;
				alltrim(str(aStruct[m.i, 4])) + ")"
		endfor
		
		return m.cStruct
	endproc
	
	procedure CreateVcxCursor
		private iSelect, aClasslist, i, j, iCount, aRec, aStruct
		
		this.cVCXCursor = "_" + sys(3)
		do while used(this.cVCXCursor)
			this.cVCXCursor = "_" + sys(3)
		enddo
		
		* Get an ordered list of the classes in the vcx
		select padr(uniqueid, fsize('uniqueid')), recno() from dbf() ;
			where .not. deleted() .and. reserved1 == "Class" ;
			into array aClasslist order by 1

		m.iSelect = select() && The original .VCX

		* Create the temporary cursor
		=afields(aStruct)
		create cursor (this.cVCXCursor) from array aStruct
		
		* Copy the header record
		select (m.iSelect)
		go top
		scatter memo to aRec
		insert into (this.cVCXCursor) from array aRec
		
		* Scan through the class list and copy the classes over
		if type('aClassList[1]') <> 'U'
			for m.i = 1 to alen(aClasslist, 1)
				go (aClasslist[m.i, 2])
				m.iCount = 1 + val(reserved2)
				for m.j = 1 to m.iCount
					scatter memo to aRec
					insert into (this.cVCXCursor) from array aRec
					skip
				endfor
			endfor
		endif
		
		* Close the original file and use the cursor we've created
		use in (m.iSelect)
		
		select (this.cVCXCursor)
	endproc
	
	procedure WriteTextFile
		private iCodePage, aText
		
		use (this.cTableName) exclusive
		
		this.oThermRef.iBasis = reccount()

		m.iCodePage = cpdbf()
		
		if this.cType = PRJTYPE_VCX
			this.CreateVcxCursor
		endif

		this.iHandle = fcreate(this.cTextName)
		if this.iHandle = -1
			this.Alert(ERR_FCREATE_LOC + this.cTextName)
			return -1
		endif
		
		* First line contains the SCCTEXT version string
		=fputs(this.iHandle, SCCTEXTVER_LOC)

		* Second line contains the CREATE TABLE compatible field list
		=fputs(this.iHandle, this.FieldList())
		* Third line contains the code page
		=fputs(this.iHandle, alltrim(str(m.iCodePage)))
		
		do case
		case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX, PRJTYPE_LABEL, ;
			PRJTYPE_REPORT, PRJTYPE_MENU, PRJTYPE_DBC)
			this.WriteText
		otherwise
			this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + m.cType)
		endcase

		=fclose(this.iHandle)
		this.iHandle = -1
		use
		return 0 && Success
	endproc

	procedure WriteTable
		private cLine, bInMemo, cMemo, cEndMark, bBinary, cFieldname, cValue, iSeconds
		m.cLine = ""
		m.bInMemo = .f.
		m.cMemo = ""
		m.cEndMark = ""
		m.bBinary = .f.
		m.cFieldname = ""
		m.cValue = ""
		
		this.oThermRef.Update(fseek(this.iHandle, 0, 1))
		m.iSeconds = seconds()
		
		do while .not. feof(this.iHandle)
			if (seconds() - m.iSeconds > 1)
				this.oThermRef.Update(fseek(this.iHandle, 0, 1))
				m.iSeconds = seconds()
			endif
			
			m.cLine = fgets(this.iHandle, 8192)
			
			if m.bInMemo
				do case
				case m.cEndMark == m.cLine
				case rat(m.cEndMark, m.cLine) <> 0
					if m.bBinary
						m.cMemo = m.cMemo + ;
							this.HexStr2BinStr(left(m.cLine, rat(m.cEndMark, m.cLine) - 1))
					else
						m.cMemo = m.cMemo + left(m.cLine, rat(m.cEndMark, m.cLine) - 1)
					endif
				otherwise
					if m.bBinary
						m.cMemo = m.cMemo + this.HexStr2BinStr(m.cLine)
					else
						m.cMemo = m.cMemo + m.cLine + CRLF
					endif
					loop				
				endcase
				
				* Drop out of if/endif to write the memo field
			else
				do case
				case empty(m.cLine)
					loop
				case m.cLine == MARKEOF
					* Don't read anything past the [EOF] mark
					return
				case m.bInMemo .and. m.cEndMark == m.cLine
				case this.IsRecordMark(m.cLine)
					append blank
					loop
				case this.IsMemoStartMark(m.cLine, @cFieldname)
					m.bInMemo = .t.
					m.bBinary = .f.
					m.cEndMark = this.SectionMark(m.cFieldname, .f., .f.)
					loop
				case this.IsBinStartMark(m.cLine, @cFieldname)
					m.bInMemo = .t.
					m.bBinary = .t.
					m.cEndMark = this.SectionMark(m.cFieldname, .f., .t.)
					loop
				case this.IsFieldMark(m.cLine, @cFieldname, @cValue)
					do case
					case inlist(type(m.cFieldname), "C", "M")
						replace (m.cFieldname) with m.cValue
					case type(m.cFieldname) = "N"
						replace (m.cFieldname) with val(m.cValue)
					case type(m.cFieldname) = "L"
						replace (m.cFieldname) with &cValue
					otherwise
						this.Cancel(ERR_UNSUPPORTEDFIELDTYPE_LOC + type(m.cFieldname))
					endcase
					loop
				otherwise
					if this.Alert(ERR_LINENOACTION_LOC + chr(13) + chr(13) + m.cLine + chr(13) + chr(13) + ;
						ERR_ALERTCONTINUE_LOC, MB_YESNO) = IDNO
						this.Cancel
					endif
				endcase
			endif
			
			* Write the memo field
			replace (m.cFieldname) with m.cMemo
			m.bInMemo = .f.
			m.cFieldname = ""
			m.cMemo = ""
			m.cEndMark = ""
		enddo
	endproc
	
	procedure IsMemoStartMark
		parameters cLine, cFieldname
		private cStartMark, cStartMark2
		if at(MARKMEMOSTARTWORD, m.cLine) = 1
			m.cFieldname = strtran(m.cLine, MARKMEMOSTARTWORD, "", 1, 1)
			m.cFieldname = left(m.cFieldname, rat(MARKMEMOSTARTWORD2, m.cFieldname) - 1)
			return .t.
		endif
		return .f.
	endproc

	procedure IsBinStartMark
		parameters cLine, cFieldname
		private cStartMark, cStartMark2
		if at(MARKBINSTARTWORD, m.cLine) = 1
			m.cFieldname = strtran(m.cLine, MARKBINSTARTWORD, "", 1, 1)
			m.cFieldname = left(m.cFieldname, rat(MARKBINSTARTWORD2, m.cFieldname) - 1)
			return .t.
		endif
		return .f.
	endproc
	
	procedure IsFieldMark
		parameters cLine, cFieldname, cValue
		if at(MARKFIELDSTART, m.cLine) = 1
			m.cFieldname = strtran(m.cLine, MARKFIELDSTART, "", 1, 1)
			m.cFieldname = left(m.cFieldname, at(MARKFIELDEND, m.cFieldname) - 1)
			m.cValue = substr(m.cLine, at(MARKFIELDEND, m.cLine))
			m.cValue = strtran(m.cValue, MARKFIELDEND, "", 1, 1)
			return .t.
		endif
		return .f.
	endproc
	
	procedure RecordMark
		parameters cUniqueId
		=fputs(this.iHandle, "")
		=fputs(this.iHandle, MARKRECORDSTART + MARKRECORDEND)
	endproc
	
	procedure IsRecordMark
		parameters cLine
		if left(m.cLine, len(MARKRECORDSTART)) == MARKRECORDSTART .and. ;
			right(m.cLine, len(MARKRECORDEND)) == MARKRECORDEND
			return .t.
		else
			return .f.
		endif
	endproc
	
	procedure WriteText
		private cExcludeList, cMemoAsCharList, cMemoAsBinList, cCharAsBinList
		m.cExcludeList = ""
		m.cMemoAsCharList = ""
		m.cMemoAsBinList = ""
		m.cCharAsBinList = ""
		m.cMemoVariesList = ""

		do case
			case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX)
				m.cExcludeFields = VCX_EXCLUDE_LIST
				m.cMemoAsCharList = VCX_MEMOASCHAR_LIST
				m.cMemoAsBinList = VCX_MEMOASBIN_LIST
				m.cCharAsBinList = VCX_CHARASBIN_LIST
				m.cMemoVariesList = VCX_MEMOVARIES_LIST
			case inlist(this.cType, PRJTYPE_REPORT, PRJTYPE_LABEL)
				m.cExcludeFields = FRX_EXCLUDE_LIST
				m.cMemoAsCharList = FRX_MEMOASCHAR_LIST
				m.cMemoAsBinList = FRX_MEMOASBIN_LIST
				m.cCharAsBinList = FRX_CHARASBIN_LIST
				m.cMemoVariesList = FRX_MEMOVARIES_LIST
			case this.cType = PRJTYPE_MENU
				m.cExcludeFields = MNX_EXCLUDE_LIST
				m.cMemoAsCharList = MNX_MEMOASCHAR_LIST
				m.cMemoAsBinList = MNX_MEMOASBIN_LIST
				m.cCharAsBinList = MNX_CHARASBIN_LIST
				m.cMemoVariesList = MNX_MEMOVARIES_LIST
			case this.cType = PRJTYPE_DBC
				m.cExcludeFields = DBC_EXCLUDE_LIST
				m.cMemoAsCharList = DBC_MEMOASCHAR_LIST
				m.cMemoAsBinList = DBC_MEMOASBIN_LIST
				m.cCharAsBinList = DBC_CHARASBIN_LIST
				m.cMemoVariesList = DBC_MEMOVARIES_LIST
			otherwise
				this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + this.cType)
		endcase

		scan
			this.oThermRef.Update(recno())
			if type("UNIQUEID") <> 'U'
				this.RecordMark(UNIQUEID)
			endif
			for i = 1 to fcount()
				if SKIPEMPTYFIELD and empty(evaluate(field(i)))
					loop
				endif
				do case
				    case UPPER(ALLTRIM(field(i))) == "METHODS" AND ;
				    	 INLIST(this.cType, PRJTYPE_FORM, PRJTYPE_VCX)
				        THIS.MethodsWrite(field(i))
				
					case " " + field(i) + " " $ m.cExcludeFields
						&& skip this field
					case " " + field(i) + " " $ m.cMemoAsCharList
						&& memo fields treated as CHAR
						this.CharWrite(field(i))
					case type(field(i)) = "C"
						if " " + field(i) + " " $ m.cCharAsBinList
							this.MemoWrite(field(i), .t.)
						else
							this.CharWrite(field(i))
						endif
					case type(field(i)) = "M"
						if " " + field(i) + " " $ m.cMemoVariesList
							&& treat as text or binary based on contents of the memofield
							if this.MemoIsBinary(field(i))
								this.MemoWrite(field(i), .t.)
							else
								this.MemoWrite(field(i), .f.)
							endif
						else
							if " " + field(i) + " " $ m.cMemoAsBinList
								&& memo fields treated as BINARY
								this.MemoWrite(field(i), .t.)
							else
								this.MemoWrite(field(i), .f.)
							endif
						endif
					case type(field(i)) = "N"
						this.NumWrite(field(i))
					case type(field(i)) = "L"
						this.BoolWrite(field(i))
					otherwise
						this.Alert(ERR_UNSUPPORTEDFIELDTYPE_LOC + type(field(i)))
				endcase
			endfor
		endscan
		this.EOFMark
	endproc
	
	procedure MemoIsBinary
		* Scan the memo field to see if it contains binary characters
		parameters cFieldname
		private i, bIsBinary, cMemo
		m.cMemo = &cFieldname
		m.bIsBinary = .t.
		do case
			case chr(0) $ m.cMemo
			otherwise
				m.bIsBinary = .f.
				if len(m.cMemo) < 126
					for m.i = 1 to len(m.cMemo)
						if asc(substr(m.cMemo, m.i, 1)) > 126
							m.bIsBinary = .t.
							exit
						endif
					endfor
				else
					for m.i = 126 to 255
						if chr(m.i) $ m.cMemo
							m.bIsBinary = .t.
							exit
						endif
					endfor
				endif
		endcase
		return m.bIsBinary
	endproc
	
	procedure EOFMark
		=fputs(this.iHandle, MARKEOF)
	endproc
	
	procedure CharWrite
		parameters cFieldname
		private cTempfield
		m.cTempfield = &cFieldname
		=fputs(this.iHandle, MARKFIELDSTART + m.cFieldname + MARKFIELDEND + m.cTempfield)
	endproc
	
	procedure MemoWrite
		parameters cFieldname, bBinary
		private i, iLen, iStart, cBuf, cBinary, cBinaryProgress, iSeconds
		=fputs(this.iHandle, this.SectionMark(m.cFieldname, .t., m.bBinary))
		m.iLen = len(&cFieldname)
		if m.bBinary
			* If we don't support merging, simply write the checksum
			if C_WRITECHECKSUMS .and. TextSupport(this.cType) == 1
				=fputs(this.iHandle, MARKCHECKSUM + sys(2007, &cFieldname))
			else
				m.cBuf = repl(chr(0), 17)
				
				m.cBinaryProgress = "0"
				this.oThermRef.UpdateTaskMessage(C_BINARYCONVERSION_LOC)
				m.iSeconds = seconds()
				
				for m.i = 1 to int(m.iLen / MAXBINLEN) + iif(m.iLen % MAXBINLEN = 0, 0, 1)
					if seconds() - m.iSeconds > 1
						m.cBinaryProgress = alltrim(str(int(((m.i * MAXBINLEN) / m.iLen) * 100)))
						this.oThermRef.UpdateTaskMessage(C_BINARYCONVERSION_LOC)
						m.iSeconds = seconds()
					endif
					m.cBinary = substr(&cFieldname, ((m.i - 1) * MAXBINLEN) + 1, MAXBINLEN)
					for m.j = 1 to int(len(m.cBinary) / 8)
						sprintf(@cBuf, "%02X%02X%02X%02X%02X%02X%02X%02X", ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 1, 1)), ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 2, 1)), ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 3, 1)), ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 4, 1)), ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 5, 1)), ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 6, 1)), ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 7, 1)), ;
							asc(substr(m.cBinary, ((m.j - 1) * 8) + 8, 1)))
						fwrite(this.iHandle, m.cBuf, 16)
					endfor
					if len(m.cBinary) % 8 = 0
						fputs(this.iHandle, "")
					endif
				endfor
				
				if len(m.cBinary) % 8 <> 0
					m.cBinary = right(m.cBinary, len(m.cBinary) % 8)
					sprintf(@cBuf, replicate("%02X", len(m.cBinary)), ;
						asc(substr(m.cBinary, 1, 1)), ;
						asc(substr(m.cBinary, 2, 1)), ;
						asc(substr(m.cBinary, 3, 1)), ;
						asc(substr(m.cBinary, 4, 1)), ;
						asc(substr(m.cBinary, 5, 1)), ;
						asc(substr(m.cBinary, 6, 1)), ;
						asc(substr(m.cBinary, 7, 1)), ;
						asc(substr(m.cBinary, 8, 1)))
					fwrite(this.iHandle, m.cBuf, len(m.cBinary) * 2)
					fputs(this.iHandle, "")
				endif
				
				this.oThermRef.UpdateTaskMessage("")
			endif
		else
			=fwrite(this.iHandle, &cFieldname)
		endif
		=fputs(this.iHandle, this.SectionMark(m.cFieldname, .f., m.bBinary))
	endproc

    procedure MethodsWrite(cFieldName)
      * write methods in alphabetical order
      fputs(this.iHandle, ;
         this.SectionMark(m.cFieldname, .t.))
      fwrite(this.iHandle, ;
         this.SortMethods(&cFieldname))
      fputs(this.iHandle, ;
         this.SectionMark(m.cFieldname, .f.))
    endproc
    
    function SortMethods(tcMethods)
      * sort methods by name
      
      * sanity checks
      assert TYPE("tcMethods") == "C"
      if EMPTY(tcMethods)
        return
      endif
      
      * avoid wrapping
      local lnMemoWidth
      lnMemoWidth = SET("MemoWidth")
      SET MEMOWIDTH TO 1024
      
      LOCAL ARRAY laMethods[1]
      LOCAL lnMethods
      lnMethods = 0
      
      local lcLine
      _MLINE = 0
      local ln
      * for each line in the methods
      FOR ln = 1 to MEMLINES(tcMethods)
         * put a CRLF after every line but the last
         if ln > 1
           laMethods[lnMethods] = laMethods[lnMethods] + CRLF
         endif
         lcLine = MLINE(tcMethods,1,_MLINE)
         * if it's a procedure line, add a new entry
         if LEFT(lcLine, LEN("PROCEDURE ")) == ;
           "PROCEDURE "
           lnMethods = lnMethods + 1
           DIMENSION laMethods[lnMethods]
           laMethods[lnMethods] = ""
         endif
         * add line to current entry
         IF lnMethods > 0
	         laMethods[lnMethods] = laMethods[lnMethods] + lcLine
	     ENDIF    
       
      ENDFOR &&* ln = 1 to MEMLINES(tcMethods)
      
      * sort the entries
      ASORT(laMETHODS)
      
      * recreate the methods in method name order
      tcmethods = ""
      FOR ln = 1 to ALEN(laMethods,1)
         tcMethods = tcMethods + laMethods[ln]
      ENDFOR &&* ln = 1 to ALEN(laMethods,1)

      SET MEMOWIDTH TO lnMemoWidth
      
    RETURN tcMethods

	procedure HexStr2BinStr
		parameters cHexStr
		private cBinStr, i
		m.cBinStr = ""

		m.cHexStr = strtran(m.cHexStr, 'A', chr(asc('9') + 1))
		m.cHexStr = strtran(m.cHexStr, 'B', chr(asc('9') + 2))
		m.cHexStr = strtran(m.cHexStr, 'C', chr(asc('9') + 3))
		m.cHexStr = strtran(m.cHexStr, 'D', chr(asc('9') + 4))
		m.cHexStr = strtran(m.cHexStr, 'E', chr(asc('9') + 5))
		m.cHexStr = strtran(m.cHexStr, 'F', chr(asc('9') + 6))
		
		for m.i = 1 to len(m.cHexStr) step 2
			m.cBinStr = m.cBinStr + ;
				chr((asc(substr(m.cHexStr, m.i, 1)) - 48) * 16 + asc(substr(m.cHexStr, m.i + 1, 1)) - 48)
		endfor

		return m.cBinStr
	endproc
	
	procedure NumWrite
		* This procedure supports the numerics found in forms, reports, etc. (basically, integers)
		parameters cFieldname
		=fputs(this.iHandle, MARKFIELDSTART + m.cFieldname + ;
			MARKFIELDEND + alltrim(str(&cFieldname, 20)))
	endproc
	
	procedure BoolWrite
		parameters cFieldname
		=fputs(this.iHandle, MARKFIELDSTART + m.cFieldname + ;
			MARKFIELDEND + iif(&cFieldname, ".T.", ".F."))
	endproc
	
	procedure SectionMark
		parameters cFieldname, lStart, bBinary
		if m.lStart
			if m.bBinary
				return MARKBINSTARTWORD + m.cFieldname + MARKBINSTARTWORD2
			else
				return MARKMEMOSTARTWORD + m.cFieldname + MARKMEMOSTARTWORD2
			endif
		else
			if m.bBinary
				return MARKBINENDWORD + m.cFieldname + MARKBINENDWORD2
			else
				return MARKMEMOENDWORD + m.cFieldname + MARKMEMOENDWORD2
			endif
		endif
	endproc

	FUNCTION JustPath
		* Returns just the pathname.
		LPARAMETERS m.filname
		m.filname = ALLTRIM(UPPER(m.filname))
		IF "\" $ m.filname
		   m.filname = SUBSTR(m.filname,1,RAT("\",m.filname))
		   IF RIGHT(m.filname,1) = "\" AND LEN(m.filname) > 1 ;
		            AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ":"
		         filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
		   ENDIF
		   RETURN m.filname
		ELSE
		   RETURN ""
		ENDIF
	ENDFUNC
	
	FUNCTION ForceExt
		* Force filename to have a particular extension.
		LPARAMETERS m.filname,m.ext
		LOCAL m.ext
		IF SUBSTR(m.ext,1,1) = "."
		   m.ext = SUBSTR(m.ext,2,3)
		ENDIF

		m.pname = THIS.justpath(m.filname)
		m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname)))
		IF AT(".",m.filname) > 0
		   m.filname = SUBSTR(m.filname,1,AT(".",m.filname)-1) + "." + m.ext
		ELSE
		   m.filname = m.filname + "." + m.ext
		ENDIF
		RETURN THIS.addbs(m.pname) + m.filname
	ENDFUNC
	
	FUNCTION JustFname
		* Return just the filename (i.e., no path) from "filname"
		LPARAMETERS m.filname
		IF RAT("\",m.filname) > 0
		   m.filname = SUBSTR(m.filname,RAT("\",m.filname)+1,255)
		ENDIF
		IF AT(":",m.filname) > 0
		   m.filname = SUBSTR(m.filname,AT(":",m.filname)+1,255)
		ENDIF
		RETURN ALLTRIM(UPPER(m.filname))
	ENDFUNC

	FUNCTION AddBS
		* Add a backslash unless there is one already there.
		LPARAMETER m.pathname
		LOCAL m.separator
		m.separator = IIF(_MAC,":","\")
		m.pathname = ALLTRIM(UPPER(m.pathname))
		IF !(RIGHT(m.pathname,1) $ "\:") AND !EMPTY(m.pathname)
		   m.pathname = m.pathname + m.separator
		ENDIF
		RETURN m.pathname
	ENDFUNC

	FUNCTION JustStem
		* Return just the stem name from "filname"
		LPARAMETERS m.filname
		IF RAT("\",m.filname) > 0
		   m.filname = SUBSTR(m.filname,RAT("\",m.filname)+1,255)
		ENDIF
		IF RAT(":",m.filname) > 0
		   m.filname = SUBSTR(m.filname,RAT(":",m.filname)+1,255)
		ENDIF
		IF AT(".",m.filname) > 0
		   m.filname = SUBSTR(m.filname,1,AT(".",m.filname)-1)
		ENDIF
		RETURN ALLTRIM(UPPER(m.filname))
	ENDFUNC

	FUNCTION justext
		* Return just the extension from "filname"
		PARAMETERS m.filname
		LOCAL m.ext
		m.filname = this.justfname(m.filname)   && prevents problems with ..\ paths
		m.ext = ""
		IF AT(".", m.filname) > 0
		   m.ext = SUBSTR(m.filname, AT(".", m.filname) + 1, 3)
		ENDIF
		RETURN UPPER(m.ext)
	ENDFUNC	

	procedure SetCodePage
		parameters m.fname, m.iCodePage
		private iHandle, cpbyte

		do case
			case m.iCodePage = 437
				m.cpbyte = 1
			case m.iCodePage = 850
				m.cpbyte = 2
			case m.iCodePage = 1252
				m.cpbyte = 3
			case m.iCodePage = 10000
				m.cpbyte = 4
			case m.iCodePage = 852
				m.cpbyte = 100
			case m.iCodePage = 866
				m.cpbyte = 101
			case m.iCodePage = 865
				m.cpbyte = 102
			case m.iCodePage = 861
				m.cpbyte = 103
			case m.iCodePage = 895
				m.cpbyte = 104
			case m.iCodePage = 620
				m.cpbyte = 105
			case m.iCodePage = 737
				m.cpbyte = 106
			case m.iCodePage = 857
				m.cpbyte = 107
			case m.iCodePage = 863
				m.cpbyte = 108
			case m.iCodePage = 10007
				m.cpbyte = 150
			case m.iCodePage = 10029
				m.cpbyte = 151
			case m.iCodePage = 10006
				m.cpbyte = 152
			case m.iCodePage = 1250
				m.cpbyte = 200
			case m.iCodePage = 1251
				m.cpbyte = 201
			case m.iCodePage = 1253
				m.cpbyte = 203
			case m.iCodePage = 1254
				m.cpbyte = 202
			case m.iCodePage = 1257
				m.cpbyte = 204
			otherwise
				* Handle the error
				return .f.
		endcase
		
		m.iHandle = fopen(m.fname, 2)
		if m.iHandle = -1
			return .f.
		else
			=fseek(m.iHandle, 29)
			=fwrite(m.iHandle, chr(m.cpbyte))
			=fclose(m.iHandle)
		endif
		return .t.
	endproc
	
	procedure GetReportStructure
		parameters aStruct
		aStruct[1, 1] = "PLATFORM"
		aStruct[1, 2] = "C"
		aStruct[1, 3] = 8
		aStruct[1, 4] = 0
		aStruct[2, 1] = "UNIQUEID"
		aStruct[2, 2] = "C"
		aStruct[2, 3] = 10
		aStruct[2, 4] = 0
		aStruct[3, 1] = "TIMESTAMP"
		aStruct[3, 2] = "N"
		aStruct[3, 3] = 10
		aStruct[3, 4] = 0
		aStruct[4, 1] = "OBJTYPE"
		aStruct[4, 2] = "N"
		aStruct[4, 3] = 2
		aStruct[4, 4] = 0
		aStruct[5, 1] = "OBJCODE"
		aStruct[5, 2] = "N"
		aStruct[5, 3] = 3
		aStruct[5, 4] = 0
		aStruct[6, 1] = "NAME"
		aStruct[6, 2] = "M"
		aStruct[6, 3] = 4
		aStruct[6, 4] = 0
		aStruct[7, 1] = "EXPR"
		aStruct[7, 2] = "M"
		aStruct[7, 3] = 4
		aStruct[7, 4] = 0
		aStruct[8, 1] = "VPOS"
		aStruct[8, 2] = "N"
		aStruct[8, 3] = 9
		aStruct[8, 4] = 3
		aStruct[9, 1] = "HPOS"
		aStruct[9, 2] = "N"
		aStruct[9, 3] = 9
		aStruct[9, 4] = 3
		aStruct[10, 1] = "HEIGHT"
		aStruct[10, 2] = "N"
		aStruct[10, 3] = 9
		aStruct[10, 4] = 3
		aStruct[11, 1] = "WIDTH"
		aStruct[11, 2] = "N"
		aStruct[11, 3] = 9
		aStruct[11, 4] = 3
		aStruct[12, 1] = "STYLE"
		aStruct[12, 2] = "M"
		aStruct[12, 3] = 4
		aStruct[12, 4] = 0
		aStruct[13, 1] = "PICTURE"
		aStruct[13, 2] = "M"
		aStruct[13, 3] = 4
		aStruct[13, 4] = 0
		aStruct[14, 1] = "ORDER"
		aStruct[14, 2] = "M"
		aStruct[14, 3] = 4
		aStruct[14, 4] = 0
		aStruct[15, 1] = "UNIQUE"
		aStruct[15, 2] = "L"
		aStruct[15, 3] = 1
		aStruct[15, 4] = 0
		aStruct[16, 1] = "COMMENT"
		aStruct[16, 2] = "M"
		aStruct[16, 3] = 4
		aStruct[16, 4] = 0
		aStruct[17, 1] = "ENVIRON"
		aStruct[17, 2] = "L"
		aStruct[17, 3] = 1
		aStruct[17, 4] = 0
		aStruct[18, 1] = "BOXCHAR"
		aStruct[18, 2] = "C"
		aStruct[18, 3] = 1
		aStruct[18, 4] = 0
		aStruct[19, 1] = "FILLCHAR"
		aStruct[19, 2] = "C"
		aStruct[19, 3] = 1
		aStruct[19, 4] = 0
		aStruct[20, 1] = "TAG"
		aStruct[20, 2] = "M"
		aStruct[20, 3] = 4
		aStruct[20, 4] = 0
		aStruct[21, 1] = "TAG2"
		aStruct[21, 2] = "M"
		aStruct[21, 3] = 4
		aStruct[21, 4] = 0
		aStruct[22, 1] = "PENRED"
		aStruct[22, 2] = "N"
		aStruct[22, 3] = 5
		aStruct[22, 4] = 0
		aStruct[23, 1] = "PENGREEN"
		aStruct[23, 2] = "N"
		aStruct[23, 3] = 5
		aStruct[23, 4] = 0
		aStruct[24, 1] = "PENBLUE"
		aStruct[24, 2] = "N"
		aStruct[24, 3] = 5
		aStruct[24, 4] = 0
		aStruct[25, 1] = "FILLRED"
		aStruct[25, 2] = "N"
		aStruct[25, 3] = 5
		aStruct[25, 4] = 0
		aStruct[26, 1] = "FILLGREEN"
		aStruct[26, 2] = "N"
		aStruct[26, 3] = 5
		aStruct[26, 4] = 0
		aStruct[27, 1] = "FILLBLUE"
		aStruct[27, 2] = "N"
		aStruct[27, 3] = 5
		aStruct[27, 4] = 0
		aStruct[28, 1] = "PENSIZE"
		aStruct[28, 2] = "N"
		aStruct[28, 3] = 5
		aStruct[28, 4] = 0
		aStruct[29, 1] = "PENPAT"
		aStruct[29, 2] = "N"
		aStruct[29, 3] = 5
		aStruct[29, 4] = 0
		aStruct[30, 1] = "FILLPAT"
		aStruct[30, 2] = "N"
		aStruct[30, 3] = 5
		aStruct[30, 4] = 0
		aStruct[31, 1] = "FONTFACE"
		aStruct[31, 2] = "M"
		aStruct[31, 3] = 4
		aStruct[31, 4] = 0
		aStruct[32, 1] = "FONTSTYLE"
		aStruct[32, 2] = "N"
		aStruct[32, 3] = 3
		aStruct[32, 4] = 0
		aStruct[33, 1] = "FONTSIZE"
		aStruct[33, 2] = "N"
		aStruct[33, 3] = 3
		aStruct[33, 4] = 0
		aStruct[34, 1] = "MODE"
		aStruct[34, 2] = "N"
		aStruct[34, 3] = 3
		aStruct[34, 4] = 0
		aStruct[35, 1] = "RULER"
		aStruct[35, 2] = "N"
		aStruct[35, 3] = 1
		aStruct[35, 4] = 0
		aStruct[36, 1] = "RULERLINES"
		aStruct[36, 2] = "N"
		aStruct[36, 3] = 1
		aStruct[36, 4] = 0
		aStruct[37, 1] = "GRID"
		aStruct[37, 2] = "L"
		aStruct[37, 3] = 1
		aStruct[37, 4] = 0
		aStruct[38, 1] = "GRIDV"
		aStruct[38, 2] = "N"
		aStruct[38, 3] = 2
		aStruct[38, 4] = 0
		aStruct[39, 1] = "GRIDH"
		aStruct[39, 2] = "N"
		aStruct[39, 3] = 2
		aStruct[39, 4] = 0
		aStruct[40, 1] = "FLOAT"
		aStruct[40, 2] = "L"
		aStruct[40, 3] = 1
		aStruct[40, 4] = 0
		aStruct[41, 1] = "STRETCH"
		aStruct[41, 2] = "L"
		aStruct[41, 3] = 1
		aStruct[41, 4] = 0
		aStruct[42, 1] = "STRETCHTOP"
		aStruct[42, 2] = "L"
		aStruct[42, 3] = 1
		aStruct[42, 4] = 0
		aStruct[43, 1] = "TOP"
		aStruct[43, 2] = "L"
		aStruct[43, 3] = 1
		aStruct[43, 4] = 0
		aStruct[44, 1] = "BOTTOM"
		aStruct[44, 2] = "L"
		aStruct[44, 3] = 1
		aStruct[44, 4] = 0
		aStruct[45, 1] = "SUPTYPE"
		aStruct[45, 2] = "N"
		aStruct[45, 3] = 1
		aStruct[45, 4] = 0
		aStruct[46, 1] = "SUPREST"
		aStruct[46, 2] = "N"
		aStruct[46, 3] = 1
		aStruct[46, 4] = 0
		aStruct[47, 1] = "NOREPEAT"
		aStruct[47, 2] = "L"
		aStruct[47, 3] = 1
		aStruct[47, 4] = 0
		aStruct[48, 1] = "RESETRPT"
		aStruct[48, 2] = "N"
		aStruct[48, 3] = 2
		aStruct[48, 4] = 0
		aStruct[49, 1] = "PAGEBREAK"
		aStruct[49, 2] = "L"
		aStruct[49, 3] = 1
		aStruct[49, 4] = 0
		aStruct[50, 1] = "COLBREAK"
		aStruct[50, 2] = "L"
		aStruct[50, 3] = 1
		aStruct[50, 4] = 0
		aStruct[51, 1] = "RESETPAGE"
		aStruct[51, 2] = "L"
		aStruct[51, 3] = 1
		aStruct[51, 4] = 0
		aStruct[52, 1] = "GENERAL"
		aStruct[52, 2] = "N"
		aStruct[52, 3] = 3
		aStruct[52, 4] = 0
		aStruct[53, 1] = "SPACING"
		aStruct[53, 2] = "N"
		aStruct[53, 3] = 3
		aStruct[53, 4] = 0
		aStruct[54, 1] = "DOUBLE"
		aStruct[54, 2] = "L"
		aStruct[54, 3] = 1
		aStruct[54, 4] = 0
		aStruct[55, 1] = "SWAPHEADER"
		aStruct[55, 2] = "L"
		aStruct[55, 3] = 1
		aStruct[55, 4] = 0
		aStruct[56, 1] = "SWAPFOOTER"
		aStruct[56, 2] = "L"
		aStruct[56, 3] = 1
		aStruct[56, 4] = 0
		aStruct[57, 1] = "EJECTBEFOR"
		aStruct[57, 2] = "L"
		aStruct[57, 3] = 1
		aStruct[57, 4] = 0
		aStruct[58, 1] = "EJECTAFTER"
		aStruct[58, 2] = "L"
		aStruct[58, 3] = 1
		aStruct[58, 4] = 0
		aStruct[59, 1] = "PLAIN"
		aStruct[59, 2] = "L"
		aStruct[59, 3] = 1
		aStruct[59, 4] = 0
		aStruct[60, 1] = "SUMMARY"
		aStruct[60, 2] = "L"
		aStruct[60, 3] = 1
		aStruct[60, 4] = 0
		aStruct[61, 1] = "ADDALIAS"
		aStruct[61, 2] = "L"
		aStruct[61, 3] = 1
		aStruct[61, 4] = 0
		aStruct[62, 1] = "OFFSET"
		aStruct[62, 2] = "N"
		aStruct[62, 3] = 3
		aStruct[62, 4] = 0
		aStruct[63, 1] = "TOPMARGIN"
		aStruct[63, 2] = "N"
		aStruct[63, 3] = 3
		aStruct[63, 4] = 0
		aStruct[64, 1] = "BOTMARGIN"
		aStruct[64, 2] = "N"
		aStruct[64, 3] = 3
		aStruct[64, 4] = 0
		aStruct[65, 1] = "TOTALTYPE"
		aStruct[65, 2] = "N"
		aStruct[65, 3] = 2
		aStruct[65, 4] = 0
		aStruct[66, 1] = "RESETTOTAL"
		aStruct[66, 2] = "N"
		aStruct[66, 3] = 2
		aStruct[66, 4] = 0
		aStruct[67, 1] = "RESOID"
		aStruct[67, 2] = "N"
		aStruct[67, 3] = 3
		aStruct[67, 4] = 0
		aStruct[68, 1] = "CURPOS"
		aStruct[68, 2] = "L"
		aStruct[68, 3] = 1
		aStruct[68, 4] = 0
		aStruct[69, 1] = "SUPALWAYS"
		aStruct[69, 2] = "L"
		aStruct[69, 3] = 1
		aStruct[69, 4] = 0
		aStruct[70, 1] = "SUPOVFLOW"
		aStruct[70, 2] = "L"
		aStruct[70, 3] = 1
		aStruct[70, 4] = 0
		aStruct[71, 1] = "SUPRPCOL"
		aStruct[71, 2] = "N"
		aStruct[71, 3] = 1
		aStruct[71, 4] = 0
		aStruct[72, 1] = "SUPGROUP"
		aStruct[72, 2] = "N"
		aStruct[72, 3] = 2
		aStruct[72, 4] = 0
		aStruct[73, 1] = "SUPVALCHNG"
		aStruct[73, 2] = "L"
		aStruct[73, 3] = 1
		aStruct[73, 4] = 0
		aStruct[74, 1] = "SUPEXPR"
		aStruct[74, 2] = "M"
		aStruct[74, 3] = 4
		aStruct[74, 4] = 0
		aStruct[75, 1] = "USER"
		aStruct[75, 2] = "M"
		aStruct[75, 3] = 4
		aStruct[75, 4] = 0
	endproc	
enddefine

DEFINE CLASS thermometer AS form

	Top = 196
	Left = 142
	Height = 88
	Width = 356
	AutoCenter = .T.
	BackColor = RGB(192,192,192)
	BorderStyle = 0
	Caption = ""
	Closable = .F.
	ControlBox = .F.
	MaxButton = .F.
	MinButton = .F.
	Movable = .F.
	AlwaysOnTop = .F.
	ipercentage = 0
	iBasis = 0
	ccurrenttask = ''
	shpthermbarmaxwidth = 322
	cthermref = ""
	Name = "thermometer"

	ADD OBJECT shape10 AS shape WITH ;
		BorderColor = RGB(128,128,128), ;
		Height = 81, ;
		Left = 3, ;
		Top = 3, ;
		Width = 1, ;
		Name = "Shape10"


	ADD OBJECT shape9 AS shape WITH ;
		BorderColor = RGB(128,128,128), ;
		Height = 1, ;
		Left = 3, ;
		Top = 3, ;
		Width = 349, ;
		Name = "Shape9"


	ADD OBJECT shape8 AS shape WITH ;
		BorderColor = RGB(255,255,255), ;
		Height = 82, ;
		Left = 352, ;
		Top = 3, ;
		Width = 1, ;
		Name = "Shape8"


	ADD OBJECT shape7 AS shape WITH ;
		BorderColor = RGB(255,255,255), ;
		Height = 1, ;
		Left = 3, ;
		Top = 84, ;
		Width = 350, ;
		Name = "Shape7"


	ADD OBJECT shape6 AS shape WITH ;
		BorderColor = RGB(128,128,128), ;
		Height = 86, ;
		Left = 354, ;
		Top = 1, ;
		Width = 1, ;
		Name = "Shape6"


	ADD OBJECT shape4 AS shape WITH ;
		BorderColor = RGB(128,128,128), ;
		Height = 1, ;
		Left = 1, ;
		Top = 86, ;
		Width = 354, ;
		Name = "Shape4"


	ADD OBJECT shape3 AS shape WITH ;
		BorderColor = RGB(255,255,255), ;
		Height = 85, ;
		Left = 1, ;
		Top = 1, ;
		Width = 1, ;
		Name = "Shape3"


	ADD OBJECT shape2 AS shape WITH ;
		BorderColor = RGB(255,255,255), ;
		Height = 1, ;
		Left = 1, ;
		Top = 1, ;
		Width = 353, ;
		Name = "Shape2"


	ADD OBJECT shape1 AS shape WITH ;
		BackStyle = 0, ;
		Height = 88, ;
		Left = 0, ;
		Top = 0, ;
		Width = 356, ;
		Name = "Shape1"


	ADD OBJECT shape5 AS shape WITH ;
		BorderStyle = 0, ;
		FillColor = RGB(192,192,192), ;
		FillStyle = 0, ;
		Height = 15, ;
		Left = 17, ;
		Top = 47, ;
		Width = 322, ;
		Name = "Shape5"


	ADD OBJECT lbltitle AS label WITH ;
		FontName = WIN32FONT, ;
		FontSize = 8, ;
		BackStyle = 0, ;
		BackColor = RGB(192,192,192), ;
		Caption = "", ;
		Height = 16, ;
		Left = 18, ;
		Top = 14, ;
		Width = 319, ;
		WordWrap = .F., ;
		Name = "lblTitle"


	ADD OBJECT lbltask AS label WITH ;
		FontName = WIN32FONT, ;
		FontSize = 8, ;
		BackStyle = 0, ;
		BackColor = RGB(192,192,192), ;
		Caption = "", ;
		Height = 16, ;
		Left = 18, ;
		Top = 27, ;
		Width = 319, ;
		WordWrap = .F., ;
		Name = "lblTask"


	ADD OBJECT shpthermbar AS shape WITH ;
		BorderStyle = 0, ;
		FillColor = RGB(128,128,128), ;
		FillStyle = 0, ;
		Height = 16, ;
		Left = 17, ;
		Top = 46, ;
		Width = 0, ;
		Name = "shpThermBar"


	ADD OBJECT lblpercentage AS label WITH ;
		FontName = WIN32FONT, ;
		FontSize = 8, ;
		BackStyle = 0, ;
		Caption = "0%", ;
		Height = 13, ;
		Left = 170, ;
		Top = 47, ;
		Width = 16, ;
		Name = "lblPercentage"


	ADD OBJECT lblpercentage2 AS label WITH ;
		FontName = WIN32FONT, ;
		FontSize = 8, ;
		BackColor = RGB(0,0,255), ;
		BackStyle = 0, ;
		Caption = "Label1", ;
		ForeColor = RGB(255,255,255), ;
		Height = 13, ;
		Left = 170, ;
		Top = 47, ;
		Width = 0, ;
		Name = "lblPercentage2"


	ADD OBJECT shape11 AS shape WITH ;
		BorderColor = RGB(128,128,128), ;
		Height = 1, ;
		Left = 16, ;
		Top = 45, ;
		Width = 322, ;
		Name = "Shape11"


	ADD OBJECT shape12 AS shape WITH ;
		BorderColor = RGB(255,255,255), ;
		Height = 1, ;
		Left = 16, ;
		Top = 61, ;
		Width = 323, ;
		Name = "Shape12"


	ADD OBJECT shape13 AS shape WITH ;
		BorderColor = RGB(128,128,128), ;
		Height = 16, ;
		Left = 16, ;
		Top = 45, ;
		Width = 1, ;
		Name = "Shape13"


	ADD OBJECT shape14 AS shape WITH ;
		BorderColor = RGB(255,255,255), ;
		Height = 17, ;
		Left = 338, ;
		Top = 45, ;
		Width = 1, ;
		Name = "Shape14"


	ADD OBJECT lblescapemessage AS label WITH ;
		FontBold = .F., ;
		FontName = WIN32FONT, ;
		FontSize = 8, ;
		Alignment = 2, ;
		BackStyle = 0, ;
		BackColor = RGB(192,192,192), ;
		Caption = "", ;
		Height = 14, ;
		Left = 17, ;
		Top = 68, ;
		Width = 322, ;
		WordWrap = .F., ;
		Name = "lblEscapeMessage"

	PROCEDURE complete
		* This is the default complete message
		parameters m.cTask
		private iSeconds
		if parameters() = 0
			m.cTask = THERMCOMPLETE_LOC
		endif
		this.Update(100,m.cTask)
	ENDPROC

	procedure UpdateTaskMessage
		* Update the task message only, used when converting binary data
		parameters cTask
		this.cCurrentTask = m.cTask
		this.lblTask.Caption = this.cCurrentTask
	endproc
	
	PROCEDURE update
		* m.iProgress is the percentage complete
		* m.cTask is displayed on the second line of the window

		parameters iProgress, cTask

		if parameters() >= 2 .and. type('m.cTask') = 'C'
			* If we're specifically passed a null string, clear the current task,
			* otherwise leave it alone
			this.cCurrentTask = m.cTask
		endif
		
		if ! this.lblTask.Caption == this.cCurrentTask
			this.lblTask.Caption = this.cCurrentTask
		endif

		if this.iBasis <> 0
			* interpret m.iProgress in terms of this.iBasis
			m.iPercentage = int((m.iProgress / this.iBasis) * 100)
		else
			m.iPercentage = m.iProgress
		endif
		
		m.iPercentage = min(100,max(0,m.iPercentage))
		
		if m.iPercentage = this.iPercentage
			RETURN
		endif
		
		if len(alltrim(str(m.iPercentage,3)))<>len(alltrim(str(this.iPercentage,3)))
			iAvgCharWidth=fontmetric(6,this.lblPercentage.FontName, ;
				this.lblPercentage.FontSize, ;
				iif(this.lblPercentage.FontBold,'B','')+ ;
				iif(this.lblPercentage.FontItalic,'I',''))
			this.lblPercentage.Width=txtwidth(alltrim(str(m.iPercentage,3)) + '%', ;
				this.lblPercentage.FontName,this.lblPercentage.FontSize, ;
				iif(this.lblPercentage.FontBold,'B','')+ ;
				iif(this.lblPercentage.FontItalic,'I','')) * iAvgCharWidth
			this.lblPercentage.Left=int((this.shpThermBarMaxWidth- ;
				this.lblPercentage.Width) / 2)+this.shpThermBar.Left-1
			this.lblPercentage2.Left=this.lblPercentage.Left
		endif
		this.shpThermBar.Width = int((this.shpThermBarMaxWidth)*m.iPercentage/100)
		this.lblPercentage.Caption = alltrim(str(m.iPercentage,3)) + '%'
		this.lblPercentage2.Caption = this.lblPercentage.Caption
		if this.shpThermBar.Left + this.shpThermBar.Width -1 >= ;
			this.lblPercentage2.Left
			if this.shpThermBar.Left + this.shpThermBar.Width - 1 >= ;
				this.lblPercentage2.Left + this.lblPercentage.Width - 1
				this.lblPercentage2.Width = this.lblPercentage.Width
			else
				this.lblPercentage2.Width = ;
					this.shpThermBar.Left + this.shpThermBar.Width - ;
					this.lblPercentage2.Left - 1
			endif
		else
			this.lblPercentage2.Width = 0
		endif
		this.iPercentage = m.iPercentage
	ENDPROC

	PROCEDURE Init
		* m.cTitle is displayed on the first line of the window
		* m.iInterval is the frequency used for updating the thermometer
		parameters cTitle, iInterval
		this.lblTitle.Caption = iif(empty(m.cTitle),'',m.cTitle)
		this.shpThermBar.FillColor = rgb(128,128,128)
		local cColor

		* Check to see if the fontmetrics for MS Sans Serif matches
		* those on the system developed. If not, switch to Arial. 
		* The RETURN value indicates whether the font was changed.
		if fontmetric(1, WIN32FONT, 8, '') <> 13 .or. ;
			fontmetric(4, WIN32FONT, 8, '') <> 2 .or. ;
			fontmetric(6, WIN32FONT, 8, '') <> 5 .or. ;
			fontmetric(7, WIN32FONT, 8, '') <> 11
			this.SetAll('FontName', WIN95FONT)
		endif

		m.cColor = rgbscheme(1, 2)
		m.cColor = 'rgb(' + substr(m.cColor, at(',', m.cColor, 3) + 1)
		this.BackColor = &cColor
		this.Shape5.FillColor = &cColor
	ENDPROC
ENDDEFINE